module suty
  !
  ! Fortran Interface for sutyA.s
  !
  !
  ! LICENSE AGREEMENT:
  !
  ! You agree that we don't agree to anything.
  !
  !
  ! DISCLAIMER OF WARRANTIES:
  !
  ! This software is provided to you "AS IS," and the authors and
  ! contributors disclaim any warranty or liability obligations to you
  ! of any kind, implied or express, including but not limited to the
  ! warranties of merchantability, fitness for a particular purpose,
  ! and non-infringement.
  ! 
  implicit none
  private
  public quicksort
  public cpmems1,cpmems2,cpmems4,cpmems8
  public cpmemf1,cpmemf2,cpmemf4,cpmemf8
  public clemem1,clemem2,clemem4,clemem8
  public f2a,i2a
  public initSuty
  public muldivpd
  public divpd
  public median
  public kthsmallest
  public getPBS
  public cpuidx,cpuida,cpuidb,cpuidc,cpuidd
  public fxsave, setdaz
  public a2i,a2f
  public bsdshmat,bsdshmctl,bsdshmdt,bsdshmget
  public geterrnoa
  public setup_SIGTERM,setup_SIGHUP,setup_SIGCHLD
  public csetenv,cunsetenv
  public toExtenstion
  public pid2bin

  !
  type timespec
     integer*8 tv_sec
     integer*8 tv_nsec
  end type timespec

  !
  type nstat
     integer*4 st_dev
     integer*4 st_ino
     integer*4 st_mode
     integer*4 st_nlink
     integer*4 st_uid
     integer*4 st_gid
     integer*4 st_rdev
     type(timespec) st_atimespec
     type(timespec) st_mtimespec
     type(timespec) st_ctimespec
     integer*8 st_size
     integer*8 st_blocks
     integer*4 st_blksize
     integer*4 st_flags
     integer*4 st_gen
     type(timespec) st_birthitmespec
     integer*8 pad
  end type nstat

  !
  integer,parameter::F_OK = 0
  integer,parameter::X_OK = 1
  integer,parameter::W_OK = 2
  integer,parameter::R_OK = 4

  !
  integer,public,parameter::IPC_R       = int(o'000400' ,8)
  integer,public,parameter::IPC_W       = int(o'000200' ,8)
  integer,public,parameter::IPC_M       = int(o'010000' ,8)
  integer,public,parameter::IPC_CREAT   = int(o'001000' ,8)
  integer,public,parameter::IPC_EXCL    = int(o'002000' ,8)
  integer,public,parameter::IPC_NOWAIT  = int(o'004000' ,8)
  integer,public,parameter::IPC_PRIVATE = 0
  integer,public,parameter::IPC_RMID    = 0
  integer,public,parameter::IPC_SET     = 1
  integer,public,parameter::IPC_STAT    = 2
  integer,public,parameter::IPC_INFO    = 3

  integer,public,parameter::SIGHUP    =  1 ! hangup */
  integer,public,parameter::SIGINT    =  2 ! interrupt */
  integer,public,parameter::SIGQUIT   =  3 ! quit */
  integer,public,parameter::SIGILL    =  4 ! illegal instr. (not reset when caught) */
  integer,public,parameter::SIGTRAP   =  5 ! trace trap (not reset when caught) */
  integer,public,parameter::SIGABRT   =  6 ! abort() */
  integer,public,parameter::SIGEMT    =  7 ! EMT instruction */
  integer,public,parameter::SIGFPE    =  8 ! floating point exception */
  integer,public,parameter::SIGKILL   =  9 ! kill (cannot be caught or ignored) */
  integer,public,parameter::SIGBUS    = 10 ! bus error */
  integer,public,parameter::SIGSEGV   = 11 ! segmentation violation */
  integer,public,parameter::SIGSYS    = 12 ! non-existent system call invoked */
  integer,public,parameter::SIGPIPE   = 13 ! write on a pipe with no one to read it */
  integer,public,parameter::SIGALRM   = 14 ! alarm clock */
  integer,public,parameter::SIGTERM   = 15 ! software termination signal from kill */
  integer,public,parameter::SIGURG    = 16 ! urgent condition on IO channel */
  integer,public,parameter::SIGSTOP   = 17 ! sendable stop signal not from tty */
  integer,public,parameter::SIGTSTP   = 18 ! stop signal from tty */
  integer,public,parameter::SIGCONT   = 19 ! continue a stopped process */
  integer,public,parameter::SIGCHLD   = 20 ! to parent on child stop or exit */
  integer,public,parameter::SIGTTIN   = 21 ! to readers pgrp upon background tty read */
  integer,public,parameter::SIGTTOU   = 22 ! like TTIN if (tp->t_local&LTOSTOP) */
  integer,public,parameter::SIGIO     = 23 ! input/output possible signal */
  integer,public,parameter::SIGXCPU   = 24 ! exceeded CPU time limit */
  integer,public,parameter::SIGXFSZ   = 25 ! exceeded file size limit */
  integer,public,parameter::SIGVTALRM = 26 ! virtual time alarm */
  integer,public,parameter::SIGPROF   = 27 ! profiling time alarm */
  integer,public,parameter::SIGWINCH  = 28 ! window size changes */
  integer,public,parameter::SIGINFO   = 29 ! information request */
  integer,public,parameter::SIGUSR1   = 30 ! user defined signal 1 */
  integer,public,parameter::SIGUSR2   = 31 ! user defined signal 2 */
  integer,public,parameter::SIGTHR    = 32 ! reserved by thread library. */

  !
  integer,public,parameter::SHMSZ=2147479552

  interface swap
     module procedure swap_r
     module procedure swap_i
  end interface swap

  interface initSuty
     subroutine initSuty(eps,fth)
       real*8,intent(in)::eps,fth
     end subroutine initSuty
  end interface initSuty
  interface
     subroutine muldivpd(a,b,c,n)
       integer,intent(in),value::a,b,c,n
     end subroutine muldivpd
  end interface
  interface divpd
     subroutine divpd(a,c,n)
       integer,intent(in),value::a,c,n
     end subroutine divpd
  end interface divpd

  interface
     subroutine cpmems1(d,s,n)
       integer,intent(in),value::d,s,n
     end subroutine cpmems1
     integer function cpmemf1(d,s,n)
       integer,intent(in),value::d,s,n
     end function cpmemf1
  end interface
  interface
     subroutine cpmems2(d,s,n)
       integer,intent(in),value::d,s,n
     end subroutine cpmems2
     integer function cpmemf2(d,s,n)
       integer,intent(in),value::d,s,n
     end function cpmemf2
  end interface
  interface
     subroutine cpmems4(d,s,n)
       integer,intent(in),value::d,s,n
     end subroutine cpmems4
     integer function cpmemf4(d,s,n)
       integer,intent(in),value::d,s,n
     end function cpmemf4
  end interface
  interface
     subroutine cpmems8(d,s,n)
       integer,intent(in),value::d,s,n
     end subroutine cpmems8
     integer function cpmemf8(d,s,n)
       integer,intent(in),value::d,s,n
     end function cpmemf8
  end interface

  interface
     subroutine clemem1(d,n)
       integer,intent(in),value::d,n
     end subroutine clemem1
  end interface
  interface
     subroutine clemem2(d,n)
       integer,intent(in),value::d,n
     end subroutine clemem2
  end interface
  interface
     subroutine clemem4(d,n)
       integer,intent(in),value::d,n
     end subroutine clemem4
  end interface
  interface
     subroutine clemem8(d,n)
       integer,intent(in),value::d,n
     end subroutine clemem8
  end interface

  interface i2a
     module procedure i2a_8
     module procedure i2a_4
     module procedure i2a_2
  end interface i2a
  
  interface kthsmallest
     subroutine kthsmallest(a,n,k)
       integer,intent(in),value::a,n,k
     end subroutine kthsmallest
  end interface kthsmallest

  interface cpuida
     integer*4 function cpuida(i)
       integer*4,intent(in),value::i
     end function cpuida
  end interface
  interface cpuidb
     integer*4 function cpuidb(i)
       integer*4,intent(in),value::i
     end function cpuidb
  end interface
  interface cpuidc
     integer*4 function cpuidc(i)
       integer*4,intent(in),value::i
     end function cpuidc
  end interface
  interface cpuidd
     integer*4 function cpuidd(i)
       integer*4,intent(in),value::i
     end function cpuidd
  end interface

  interface
     subroutine setdaz(i)
       integer,intent(in),value::i
     end subroutine setdaz
  end interface
  interface
     subroutine fxsave(i)
       integer,intent(in),value::i
     end subroutine fxsave
  end interface

  interface 
     integer function bsdshmget(key,size,flg)
       integer,intent(in),value::key,size,flg
     end function bsdshmget
  end interface
  interface 
     integer function bsdshmat(shmid,shmaddr,flg)
       integer,intent(in),value::shmid,shmaddr,flg
     end function bsdshmat
  end interface
  interface 
     integer function bsdshmdt(shmaddr)
       integer,intent(in),value::shmaddr
     end function bsdshmdt
  end interface
  interface 
     integer function bsdshmctl(shmid,cmd,pbuf)
       integer,intent(in),value::shmid,cmd,pbuf
     end function bsdshmctl
  end interface

  interface     
     subroutine setup_SIGTERM(a)
       integer,intent(in),value::a
     end subroutine setup_SIGTERM
  end interface
  interface     
     subroutine setup_SIGHUP(a)
       integer,intent(in),value::a
     end subroutine setup_SIGHUP
  end interface
  interface     
     subroutine setup_SIGCHLD
     end subroutine setup_SIGCHLD
  end interface

  interface 
     integer function bsdstat(ppath, pub)
       integer,intent(in),value::ppath,pub
     end function bsdstat
  end interface
  
  interface geterrnoa
     integer function geterrnoa()
     end function geterrnoa
  end interface geterrnoa

  interface
     subroutine errmess(s)
       character*(*),intent(in)::s
     end subroutine errmess
  end interface
  
  interface 
     integer function csetenv(n,v,ov)
       character*(*),intent(in)::n
       character*(*),intent(in)::v
       integer,intent(in)::ov
     end function csetenv
  end interface
  interface
     integer function cunsetenv(n)
       character*(*),intent(in)::n
     end function cunsetenv
  end interface

  interface 
     subroutine pid2bin(p,f)
       integer,intent(in),value::p,f
     end subroutine pid2bin
  end interface

contains

  !
  character*32 function i2a_8(i,digit,hex)
    integer*8,intent(in)::i
    integer,intent(in),optional::digit
    logical,intent(in),optional::hex
    integer l
    if(present(hex)) then
       write(i2a_8,"(Z32)") i       
    else
       write(i2a_8,*) i
    end if
    i2a_8=adjustl(i2a_8)    
    if(present(digit).and.digit>0) then
       l=len_trim(i2a_8)
       if(l<digit) then
          i2a_8(digit-l:)=i2a_8(1:)
          i2a_8(1:digit-l-1)=" "
       end if
    end if
  end function i2a_8
  character*32 function i2a_4(i,digit,hex)
    integer*4,intent(in)::i
    integer,intent(in),optional::digit
    logical,intent(in),optional::hex
    i2a_4=i2a_8(int(i,kind=8),digit,hex)
  end function i2a_4
  character*32 function i2a_2(i,digit,hex)
    integer*2,intent(in)::i
    integer,intent(in),optional::digit
    logical,intent(in),optional::hex
    i2a_2=i2a_8(int(i,kind=8),digit,hex)
  end function i2a_2
  
  !
  character*32 function f2a(f,fdigit)
    real,intent(in)::f
    integer,intent(in),optional::fdigit
    integer i,j,k,p
    character*32 ex
    write(f2a,*) f
    f2a=adjustl(f2a)
    if(present(fdigit)) then
       ex=""
       j=index(f2a,"E") ! the first exp
       if(j==0) j=index(f2a,"e")
       if(j/=0) then
          ex=trim(f2a(j:))
          p=0
          do i=2,len_trim(ex)
             ! remove leading zeros from exp
             if(ex(i:i)=="0".and.p==0) then
                p=i
             else if(ex(i:i)/="0".and.p/=0) then
                ex(p:)=ex(i:)
             end if
          end do
          k=j-1
          f2a(j:)=""
       end if
       k=len_trim(f2a)  ! the last digit
       i=index(f2a,".") ! dot 
       if(i>0) then
          if(fdigit<0) then
             ! remove trailing zeros
             do i=k-1,i+1,-1
                if(f2a(i:i)/="0") exit
                f2a(i:)=""
             end do
          else
             i=i+fdigit+1
             if(i<=32) f2a(i:)=""          
          end if
       else if(fdigit>0.and.len_trim(f2a)+fdigit+1<=32) then
          f2a=trim(f2a)//"."//repeat("0",fdigit)        
       end if
       i=len_trim(f2a)
       if(f2a(i:i)==".") then
          f2a(i+1:i+1)="0"
       else
          if(index(f2a,".")==0) f2a=trim(f2a)//".0" ! always real
       end if
       f2a=trim(f2a)//trim(ex)
    end if
  end function f2a

  ! routines for quick sort
  subroutine swap_r(a,b)
    real,intent(inout)::a,b
    real c
    c=a; a=b; b=c
  end subroutine swap_r
  subroutine swap_i(a,b)
    integer,intent(inout)::a,b
    integer c
    c=a; a=b; b=c
  end subroutine swap_i
  subroutine quicksort(a,p)
    integer,intent(inout)::a(:),p(:)
    integer i
    do i=1,size(p)
       p(i)=i
    end do
    call doQuicksort(a,p)
  end subroutine quicksort
  recursive subroutine doQuicksort(a,p)
    integer,intent(inout)::a(:),p(:)
    integer m
    if(size(a)<=1) return
    call partition(a,p,m)
    call doQuicksort(a(:m-1),p(:m-1))
    call doQuicksort(a(m:),p(m:))
  end subroutine doQuicksort
  subroutine partition(a,p,m)
    integer,intent(inout)::a(:),p(:)
    integer,intent(out)::m
    integer x,i,j
    x=a(1)
    i=0
    j=size(a)+1
    do
       j=j-1
       do 
          if(a(j)<=x) exit
          j=j-1
       end do
       i=i+1
       do 
          if(a(i)>=x) exit
          i=i+1
       end do
       if(i<j) then
          call swap(a(i),a(j))
          call swap(p(i),p(j))
       else if(i==j) then
          m=i+1
          return
       else
          m=i
          return
       end if
    end do
  end subroutine partition

  !
  real function median(n,a)
    integer,intent(in)::n
    real,intent(inout)::a(n)
    integer k
    median=0
    if(n<2) return
    if(iand(n,1)==1) then
       k=(n+1)/2
    else
       k=n/2
    end if
    call kthsmallest(loc(a),n,k)
    median=a(k)
  end function median

  integer*4 function cpuidx(i,j)
    integer,intent(in)::i
    integer,intent(in)::j
    select case(j)
    case(1)
       cpuidx=cpuida(int(i,4))
    case(2)
       cpuidx=cpuidb(int(i,4))
    case(3)
       cpuidx=cpuidc(int(i,4))
    case(4)
       cpuidx=cpuidd(int(i,4))
    case default
       cpuidx=int(0,4)
    end select
  end function cpuidx

  subroutine getPBS(pbs)
    character*(*),intent(inout)::pbs
    integer*4 reg
    integer p
    integer i,j
    pbs=""
    p=loc(pbs)
    do i=int(z"80000002",8),int(z"80000004",8)
       do j=1,4
          reg=cpuidx(i,j)
          call cpmems4(p,loc(reg),1)
          p=p+4
       end do
    end do
    pbs(48:48)=" "
    pbs=adjustl(pbs)
    call simplifyWhiteSpaces(pbs)
  end subroutine getPBS

  subroutine simplifyWhiteSpaces(str)
    character*(*),intent(inout)::str
    integer i,j,l
    j=1
    l=0
    do i=1,len_trim(str)
       if(str(i:i)==" ") then
          l=l+1
         if(l>1) cycle 
      else
         l=0
      end if
      str(j:j)=str(i:i)
      j=j+1
    end do
    str(j:)=""
  end subroutine simplifyWhiteSpaces

  !
  integer function a2i(a)
    character*(*),intent(in)::a
    integer istat
    read(a,*,iostat=istat) a2i
  end function a2i
  real function a2f(a)
    character*(*),intent(in)::a
    integer istat
  read(a,*,iostat=istat) a2f
  end function a2f
  
  !
  integer function toExtenstion(f)
    character*(*),intent(in)::f
    integer i
    toExtenstion=len_trim(f)+1
    do i=len_trim(f),1,-1
       select case(f(i:i))
       case(".")
          if(i/=1.and.f(i-1:i-1)/="/") toExtenstion=i
          exit
       case("/")
          exit
       case default
       end select
    end do
  end function toExtenstion

end module suty
